home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / gnus-salt.el.z / gnus-salt.el
Encoding:
Text File  |  1998-05-21  |  33.5 KB  |  1,020 lines
  1. ;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
  2. ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5.  
  6. ;; This file is part of GNU Emacs.
  7.  
  8. ;; GNU Emacs is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; GNU Emacs is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ;; GNU General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21. ;; Boston, MA 02111-1307, USA.
  22.  
  23. ;;; Commentary:
  24.  
  25. ;;; Code:
  26.  
  27. (eval-when-compile (require 'cl))
  28.  
  29. (require 'gnus)
  30. (require 'gnus-sum)
  31.  
  32. ;;;
  33. ;;; gnus-pick-mode
  34. ;;;
  35.  
  36. (defvar gnus-pick-mode nil
  37.   "Minor mode for providing a pick-and-read interface in Gnus summary buffers.")
  38.  
  39. (defcustom gnus-pick-display-summary nil
  40.   "*Display summary while reading."
  41.   :type 'boolean
  42.   :group 'gnus-summary-pick)
  43.  
  44. (defcustom gnus-pick-mode-hook nil
  45.   "Hook run in summary pick mode buffers."
  46.   :type 'hook
  47.   :group 'gnus-summary-pick)
  48.  
  49. (defcustom gnus-mark-unpicked-articles-as-read nil
  50.   "*If non-nil, mark all unpicked articles as read."
  51.   :type 'boolean
  52.   :group 'gnus-summary-pick)
  53.  
  54. (defcustom gnus-pick-elegant-flow t
  55.   "If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked."
  56.   :type 'boolean
  57.   :group 'gnus-summary-pick)
  58.  
  59. (defcustom gnus-summary-pick-line-format
  60.   "%-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
  61.   "*The format specification of the lines in pick buffers.
  62. It accepts the same format specs that `gnus-summary-line-format' does."
  63.   :type 'string
  64.   :group 'gnus-summary-pick)
  65.  
  66. ;;; Internal variables.
  67.  
  68. (defvar gnus-pick-mode-map nil)
  69.  
  70. (unless gnus-pick-mode-map
  71.   (setq gnus-pick-mode-map (make-sparse-keymap))
  72.  
  73.   (gnus-define-keys
  74.    gnus-pick-mode-map
  75.    "t" gnus-uu-mark-thread
  76.    "T" gnus-uu-unmark-thread
  77.    " " gnus-pick-next-page
  78.    "u" gnus-summary-unmark-as-processable
  79.    "U" gnus-summary-unmark-all-processable
  80.    "v" gnus-uu-mark-over
  81.    "r" gnus-uu-mark-region
  82.    "R" gnus-uu-unmark-region
  83.    "e" gnus-uu-mark-by-regexp
  84.    "E" gnus-uu-mark-by-regexp
  85.    "b" gnus-uu-mark-buffer
  86.    "B" gnus-uu-unmark-buffer
  87.    "." gnus-pick-article
  88.    gnus-down-mouse-2 gnus-pick-mouse-pick-region
  89.    ;;gnus-mouse-2 gnus-pick-mouse-pick
  90.    "X" gnus-pick-start-reading
  91.    "\r" gnus-pick-start-reading))
  92.  
  93. (defun gnus-pick-make-menu-bar ()
  94.   (unless (boundp 'gnus-pick-menu)
  95.     (easy-menu-define
  96.      gnus-pick-menu gnus-pick-mode-map ""
  97.      '("Pick"
  98.        ("Pick"
  99.     ["Article" gnus-summary-mark-as-processable t]
  100.     ["Thread" gnus-uu-mark-thread t]
  101.     ["Region" gnus-uu-mark-region t]
  102.     ["Regexp" gnus-uu-mark-regexp t]
  103.     ["Buffer" gnus-uu-mark-buffer t])
  104.        ("Unpick"
  105.     ["Article" gnus-summary-unmark-as-processable t]
  106.     ["Thread" gnus-uu-unmark-thread t]
  107.     ["Region" gnus-uu-unmark-region t]
  108.     ["Regexp" gnus-uu-unmark-regexp t]
  109.     ["Buffer" gnus-uu-unmark-buffer t])
  110.        ["Start reading" gnus-pick-start-reading t]
  111.        ["Switch pick mode off" gnus-pick-mode gnus-pick-mode]))))
  112.  
  113. (defun gnus-pick-mode (&optional arg)
  114.   "Minor mode for providing a pick-and-read interface in Gnus summary buffers.
  115.  
  116. \\{gnus-pick-mode-map}"
  117.   (interactive "P")
  118.   (when (eq major-mode 'gnus-summary-mode)
  119.     (if (not (set (make-local-variable 'gnus-pick-mode)
  120.           (if (null arg) (not gnus-pick-mode)
  121.             (> (prefix-numeric-value arg) 0))))
  122.     (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
  123.       ;; Make sure that we don't select any articles upon group entry.
  124.       (set (make-local-variable 'gnus-auto-select-first) nil)
  125.       ;; Change line format.
  126.       (setq gnus-summary-line-format gnus-summary-pick-line-format)
  127.       (setq gnus-summary-line-format-spec nil)
  128.       (gnus-update-format-specifications nil 'summary)
  129.       (gnus-update-summary-mark-positions)
  130.       (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
  131.       (set (make-local-variable 'gnus-summary-goto-unread) 'never)
  132.       ;; Set up the menu.
  133.       (when (gnus-visual-p 'pick-menu 'menu)
  134.     (gnus-pick-make-menu-bar))
  135.       (gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
  136.       (run-hooks 'gnus-pick-mode-hook))))
  137.  
  138. (defun gnus-pick-setup-message ()
  139.   "Make Message do the right thing on exit."
  140.   (when (and (gnus-buffer-live-p gnus-summary-buffer)
  141.          (save-excursion
  142.            (set-buffer gnus-summary-buffer)
  143.            gnus-pick-mode))
  144.     (message-add-action
  145.      '(gnus-configure-windows 'pick t) 'send 'exit 'postpone 'kill)))
  146.  
  147. (defvar gnus-pick-line-number 1)
  148. (defun gnus-pick-line-number ()
  149.   "Return the current line number."
  150.   (if (bobp)
  151.       (setq gnus-pick-line-number 1)
  152.     (incf gnus-pick-line-number)))
  153.  
  154. (defun gnus-pick-start-reading (&optional catch-up)
  155.   "Start reading the picked articles.
  156. If given a prefix, mark all unpicked articles as read."
  157.   (interactive "P")
  158.   (if gnus-newsgroup-processable
  159.       (progn
  160.         (gnus-summary-limit-to-articles nil)
  161.         (when (or catch-up gnus-mark-unpicked-articles-as-read)
  162.       (gnus-summary-limit-mark-excluded-as-read))
  163.         (gnus-summary-first-article)
  164.         (gnus-configure-windows
  165.      (if gnus-pick-display-summary 'article 'pick) t))
  166.     (if gnus-pick-elegant-flow
  167.     (progn
  168.       (when (or catch-up gnus-mark-unpicked-articles-as-read)
  169.         (gnus-summary-catchup nil t))
  170.       (if (gnus-group-quit-config gnus-newsgroup-name)
  171.           (gnus-summary-exit)
  172.         (gnus-summary-next-group)))
  173.       (error "No articles have been picked"))))
  174.  
  175. (defun gnus-pick-article (&optional arg)
  176.   "Pick the article on the current line.
  177. If ARG, pick the article on that line instead."
  178.   (interactive "P")
  179.   (when arg
  180.     (let (pos)
  181.       (save-excursion
  182.     (goto-char (point-min))
  183.     (when (zerop (forward-line (1- (prefix-numeric-value arg))))
  184.       (setq pos (point))))
  185.       (if (not pos)
  186.       (gnus-error 2 "No such line: %s" arg)
  187.     (goto-char pos))))
  188.   (gnus-summary-mark-as-processable 1))
  189.  
  190. (defun gnus-pick-mouse-pick (e)
  191.   (interactive "e")
  192.   (mouse-set-point e)
  193.   (save-excursion
  194.     (gnus-summary-mark-as-processable 1)))
  195.  
  196. (defun gnus-pick-mouse-pick-region (start-event)
  197.   "Pick articles that the mouse is dragged over.
  198. This must be bound to a button-down mouse event."
  199.   (interactive "e")
  200.   (mouse-minibuffer-check start-event)
  201.   (let* ((echo-keystrokes 0)
  202.      (start-posn (event-start start-event))
  203.      (start-point (posn-point start-posn))
  204.          (start-line (1+ (count-lines 1 start-point)))
  205.      (start-window (posn-window start-posn))
  206.      (start-frame (window-frame start-window))
  207.      (bounds (window-edges start-window))
  208.      (top (nth 1 bounds))
  209.      (bottom (if (window-minibuffer-p start-window)
  210.              (nth 3 bounds)
  211.            ;; Don't count the mode line.
  212.            (1- (nth 3 bounds))))
  213.      (click-count (1- (event-click-count start-event))))
  214.     (setq mouse-selection-click-count click-count)
  215.     (setq mouse-selection-click-count-buffer (current-buffer))
  216.     (mouse-set-point start-event)
  217.     ;; In case the down click is in the middle of some intangible text,
  218.     ;; use the end of that text, and put it in START-POINT.
  219.     (when (< (point) start-point)
  220.       (goto-char start-point))
  221.     (gnus-pick-article)
  222.     (setq start-point (point))
  223.     ;; end-of-range is used only in the single-click case.
  224.     ;; It is the place where the drag has reached so far
  225.     ;; (but not outside the window where the drag started).
  226.     (let (event end end-point last-end-point (end-of-range (point)))
  227.       (track-mouse
  228.        (while (progn
  229.         (setq event (read-event))
  230.         (or (mouse-movement-p event)
  231.             (eq (car-safe event) 'switch-frame)))
  232.      (if (eq (car-safe event) 'switch-frame)
  233.          nil
  234.        (setq end (event-end event)
  235.          end-point (posn-point end))
  236.        (when end-point
  237.          (setq last-end-point end-point))
  238.  
  239.        (cond
  240.         ;; Are we moving within the original window?
  241.         ((and (eq (posn-window end) start-window)
  242.           (integer-or-marker-p end-point))
  243.          ;; Go to START-POINT first, so that when we move to END-POINT,
  244.          ;; if it's in the middle of intangible text,
  245.          ;; point jumps in the direction away from START-POINT.
  246.          (goto-char start-point)
  247.          (goto-char end-point)
  248.          (gnus-pick-article)
  249.          ;; In case the user moved his mouse really fast, pick
  250.          ;; articles on the line between this one and the last one.
  251.          (let* ((this-line (1+ (count-lines 1 end-point)))
  252.             (min-line (min this-line start-line))
  253.             (max-line (max this-line start-line)))
  254.            (while (< min-line max-line)
  255.          (goto-line min-line)
  256.          (gnus-pick-article)
  257.          (setq min-line (1+ min-line)))
  258.            (setq start-line this-line))
  259.          (when (zerop (% click-count 3))
  260.            (setq end-of-range (point))))
  261.         (t
  262.          (let ((mouse-row (cdr (cdr (mouse-position)))))
  263.            (cond
  264.         ((null mouse-row))
  265.         ((< mouse-row top)
  266.          (mouse-scroll-subr start-window (- mouse-row top)))
  267.         ((>= mouse-row bottom)
  268.          (mouse-scroll-subr start-window
  269.                     (1+ (- mouse-row bottom)))))))))))
  270.       (when (consp event)
  271.     (let ((fun (key-binding (vector (car event)))))
  272.       ;; Run the binding of the terminating up-event, if possible.
  273.       ;; In the case of a multiple click, it gives the wrong results,
  274.       ;; because it would fail to set up a region.
  275.       (when nil
  276.         ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
  277.         ;; In this case, we can just let the up-event execute normally.
  278.         (let ((end (event-end event)))
  279.           ;; Set the position in the event before we replay it,
  280.           ;; because otherwise it may have a position in the wrong
  281.           ;; buffer.
  282.           (setcar (cdr end) end-of-range)
  283.           ;; Delete the overlay before calling the function,
  284.           ;; because delete-overlay increases buffer-modified-tick.
  285.           (push event unread-command-events))))))))
  286.  
  287. (defun gnus-pick-next-page ()
  288.   "Go to the next page.  If at the end of the buffer, start reading articles."
  289.   (interactive)
  290.   (let ((scroll-in-place nil))
  291.     (condition-case nil
  292.     (scroll-up)
  293.       (end-of-buffer (gnus-pick-start-reading)))))
  294.  
  295. ;;;
  296. ;;; gnus-binary-mode
  297. ;;;
  298.  
  299. (defvar gnus-binary-mode nil
  300.   "Minor mode for providing a binary group interface in Gnus summary buffers.")
  301.  
  302. (defvar gnus-binary-mode-hook nil
  303.   "Hook run in summary binary mode buffers.")
  304.  
  305. (defvar gnus-binary-mode-map nil)
  306.  
  307. (unless gnus-binary-mode-map
  308.   (setq gnus-binary-mode-map (make-sparse-keymap))
  309.  
  310.   (gnus-define-keys
  311.    gnus-binary-mode-map
  312.    "g" gnus-binary-show-article))
  313.  
  314. (defun gnus-binary-make-menu-bar ()
  315.   (unless (boundp 'gnus-binary-menu)
  316.     (easy-menu-define
  317.      gnus-binary-menu gnus-binary-mode-map ""
  318.      '("Pick"
  319.        ["Switch binary mode off" gnus-binary-mode t]))))
  320.  
  321. (defun gnus-binary-mode (&optional arg)
  322.   "Minor mode for providing a binary group interface in Gnus summary buffers."
  323.   (interactive "P")
  324.   (when (eq major-mode 'gnus-summary-mode)
  325.     (make-local-variable 'gnus-binary-mode)
  326.     (setq gnus-binary-mode
  327.       (if (null arg) (not gnus-binary-mode)
  328.         (> (prefix-numeric-value arg) 0)))
  329.     (when gnus-binary-mode
  330.       ;; Make sure that we don't select any articles upon group entry.
  331.       (make-local-variable 'gnus-auto-select-first)
  332.       (setq gnus-auto-select-first nil)
  333.       (make-local-variable 'gnus-summary-display-article-function)
  334.       (setq gnus-summary-display-article-function 'gnus-binary-display-article)
  335.       ;; Set up the menu.
  336.       (when (gnus-visual-p 'binary-menu 'menu)
  337.     (gnus-binary-make-menu-bar))
  338.       (gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
  339.       (run-hooks 'gnus-binary-mode-hook))))
  340.  
  341. (defun gnus-binary-display-article (article &optional all-header)
  342.   "Run ARTICLE through the binary decode functions."
  343.   (when (gnus-summary-goto-subject article)
  344.     (let ((gnus-view-pseudos 'automatic))
  345.       (gnus-uu-decode-uu))))
  346.  
  347. (defun gnus-binary-show-article (&optional arg)
  348.   "Bypass the binary functions and show the article."
  349.   (interactive "P")
  350.   (let (gnus-summary-display-article-function)
  351.     (gnus-summary-show-article arg)))
  352.  
  353. ;;;
  354. ;;; gnus-tree-mode
  355. ;;;
  356.  
  357. (defcustom gnus-tree-line-format "%(%[%3,3n%]%)"
  358.   "Format of tree elements."
  359.   :type 'string
  360.   :group 'gnus-summary-tree)
  361.  
  362. (defcustom gnus-tree-minimize-window t
  363.   "If non-nil, minimize the tree buffer window.
  364. If a number, never let the tree buffer grow taller than that number of
  365. lines."
  366.   :type 'boolean
  367.   :group 'gnus-summary-tree)
  368.  
  369. (defcustom gnus-selected-tree-face 'modeline
  370.   "*Face used for highlighting selected articles in the thread tree."
  371.   :type 'face
  372.   :group 'gnus-summary-tree)
  373.  
  374. (defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\))
  375.                  (?\{ . ?\}) (?< . ?>))
  376.   "Brackets used in tree nodes.")
  377.  
  378. (defvar gnus-tree-parent-child-edges '(?- ?\\ ?|)
  379.   "Characters used to connect parents with children.")
  380.  
  381. (defcustom gnus-tree-mode-line-format "Gnus: %%b %S %Z"
  382.   "*The format specification for the tree mode line."
  383.   :type 'string
  384.   :group 'gnus-summary-tree)
  385.  
  386. (defcustom gnus-generate-tree-function 'gnus-generate-vertical-tree
  387.   "*Function for generating a thread tree.
  388. Two predefined functions are available:
  389. `gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'."
  390.   :type '(radio (function-item gnus-generate-vertical-tree)
  391.         (function-item gnus-generate-horizontal-tree)
  392.         (function :tag "Other" nil))
  393.   :group 'gnus-summary-tree)
  394.  
  395. (defcustom gnus-tree-mode-hook nil
  396.   "*Hook run in tree mode buffers."
  397.   :type 'hook
  398.   :group 'gnus-summary-tree)
  399.  
  400. ;;; Internal variables.
  401.  
  402. (defvar gnus-tree-line-format-alist
  403.   `((?n gnus-tmp-name ?s)
  404.     (?f gnus-tmp-from ?s)
  405.     (?N gnus-tmp-number ?d)
  406.     (?\[ gnus-tmp-open-bracket ?c)
  407.     (?\] gnus-tmp-close-bracket ?c)
  408.     (?s gnus-tmp-subject ?s)))
  409.  
  410. (defvar gnus-tree-mode-line-format-alist gnus-summary-mode-line-format-alist)
  411.  
  412. (defvar gnus-tree-mode-line-format-spec nil)
  413. (defvar gnus-tree-line-format-spec nil)
  414.  
  415. (defvar gnus-tree-node-length nil)
  416. (defvar gnus-selected-tree-overlay nil)
  417.  
  418. (defvar gnus-tree-displayed-thread nil)
  419.  
  420. (defvar gnus-tree-mode-map nil)
  421. (put 'gnus-tree-mode 'mode-class 'special)
  422.  
  423. (unless gnus-tree-mode-map
  424.   (setq gnus-tree-mode-map (make-keymap))
  425.   (suppress-keymap gnus-tree-mode-map)
  426.   (gnus-define-keys
  427.    gnus-tree-mode-map
  428.    "\r" gnus-tree-select-article
  429.    gnus-mouse-2 gnus-tree-pick-article
  430.    "\C-?" gnus-tree-read-summary-keys
  431.    "h" gnus-tree-show-summary
  432.  
  433.    "\C-c\C-i" gnus-info-find-node)
  434.  
  435.   (substitute-key-definition
  436.    'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map))
  437.  
  438. (defun gnus-tree-make-menu-bar ()
  439.   (unless (boundp 'gnus-tree-menu)
  440.     (easy-menu-define
  441.      gnus-tree-menu gnus-tree-mode-map ""
  442.      '("Tree"
  443.        ["Select article" gnus-tree-select-article t]))))
  444.  
  445. (defun gnus-tree-mode ()
  446.   "Major mode for displaying thread trees."
  447.   (interactive)
  448.   (setq gnus-tree-mode-line-format-spec
  449.     (gnus-parse-format gnus-tree-mode-line-format
  450.                gnus-summary-mode-line-format-alist))
  451.   (setq gnus-tree-line-format-spec
  452.     (gnus-parse-format gnus-tree-line-format
  453.                gnus-tree-line-format-alist t))
  454.   (when (gnus-visual-p 'tree-menu 'menu)
  455.     (gnus-tree-make-menu-bar))
  456.   (kill-all-local-variables)
  457.   (gnus-simplify-mode-line)
  458.   (setq mode-name "Tree")
  459.   (setq major-mode 'gnus-tree-mode)
  460.   (use-local-map gnus-tree-mode-map)
  461.   (buffer-disable-undo (current-buffer))
  462.   (setq buffer-read-only t)
  463.   (setq truncate-lines t)
  464.   (save-excursion
  465.     (gnus-set-work-buffer)
  466.     (gnus-tree-node-insert (make-mail-header "") nil)
  467.     (setq gnus-tree-node-length (1- (point))))
  468.   (run-hooks 'gnus-tree-mode-hook))
  469.  
  470. (defun gnus-tree-read-summary-keys (&optional arg)
  471.   "Read a summary buffer key sequence and execute it."
  472.   (interactive "P")
  473.   (let ((buf (current-buffer))
  474.     win)
  475.     (gnus-article-read-summary-keys arg nil t)
  476.     (when (setq win (get-buffer-window buf))
  477.       (select-window win)
  478.       (when gnus-selected-tree-overlay
  479.     (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
  480.       (gnus-tree-minimize))))
  481.  
  482. (defun gnus-tree-show-summary ()
  483.   "Reconfigure windows to show summary buffer."
  484.   (interactive)
  485.   (if (not (gnus-buffer-live-p gnus-summary-buffer))
  486.       (error "There is no summary buffer for this tree buffer")
  487.     (gnus-configure-windows 'article)
  488.     (gnus-summary-goto-subject gnus-current-article)))
  489.  
  490. (defun gnus-tree-select-article (article)
  491.   "Select the article under point, if any."
  492.   (interactive (list (gnus-tree-article-number)))
  493.   (let ((buf (current-buffer)))
  494.     (when article
  495.       (save-excursion
  496.     (set-buffer gnus-summary-buffer)
  497.     (gnus-summary-goto-article article))
  498.       (select-window (get-buffer-window buf)))))
  499.  
  500. (defun gnus-tree-pick-article (e)
  501.   "Select the article under the mouse pointer."
  502.   (interactive "e")
  503.   (mouse-set-point e)
  504.   (gnus-tree-select-article (gnus-tree-article-number)))
  505.  
  506. (defun gnus-tree-article-number ()
  507.   (get-text-property (point) 'gnus-number))
  508.  
  509. (defun gnus-tree-article-region (article)
  510.   "Return a cons with BEG and END of the article region."
  511.   (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
  512.     (when pos
  513.       (cons pos (next-single-property-change pos 'gnus-number)))))
  514.  
  515. (defun gnus-tree-goto-article (article)
  516.   (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
  517.     (when pos
  518.       (goto-char pos))))
  519.  
  520. (defun gnus-tree-recenter ()
  521.   "Center point in the tree window."
  522.   (let ((selected (selected-window))
  523.     (tree-window (get-buffer-window gnus-tree-buffer t)))
  524.     (when tree-window
  525.       (select-window tree-window)
  526.       (when gnus-selected-tree-overlay
  527.     (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
  528.       (let* ((top (cond ((< (window-height) 4) 0)
  529.             ((< (window-height) 7) 1)
  530.             (t 2)))
  531.          (height (1- (window-height)))
  532.          (bottom (save-excursion (goto-char (point-max))
  533.                      (forward-line (- height))
  534.                      (point))))
  535.     ;; Set the window start to either `bottom', which is the biggest
  536.     ;; possible valid number, or the second line from the top,
  537.     ;; whichever is the least.
  538.     (set-window-start
  539.      tree-window (min bottom (save-excursion
  540.                    (forward-line (- top)) (point)))))
  541.       (select-window selected))))
  542.  
  543. (defun gnus-get-tree-buffer ()
  544.   "Return the tree buffer properly initialized."
  545.   (save-excursion
  546.     (set-buffer (get-buffer-create gnus-tree-buffer))
  547.     (unless (eq major-mode 'gnus-tree-mode)
  548.       (gnus-add-current-to-buffer-list)
  549.       (gnus-tree-mode))
  550.     (current-buffer)))
  551.  
  552. (defun gnus-tree-minimize ()
  553.   (when (and gnus-tree-minimize-window
  554.          (not (one-window-p)))
  555.     (let ((windows 0)
  556.       tot-win-height)
  557.       (walk-windows (lambda (window) (incf windows)))
  558.       (setq tot-win-height
  559.         (- (frame-height)
  560.            (* window-min-height (1- windows))
  561.            2))
  562.       (let* ((window-min-height 2)
  563.          (height (count-lines (point-min) (point-max)))
  564.          (min (max (1- window-min-height) height))
  565.          (tot (if (numberp gnus-tree-minimize-window)
  566.               (min gnus-tree-minimize-window min)
  567.             min))
  568.          (win (get-buffer-window (current-buffer)))
  569.          (wh (and win (1- (window-height win)))))
  570.     (setq tot (min tot tot-win-height))
  571.     (when (and win
  572.            (not (eq tot wh)))
  573.       (let ((selected (selected-window)))
  574.         (when (ignore-errors (select-window win))
  575.           (enlarge-window (- tot wh))
  576.           (select-window selected))))))))
  577.  
  578. ;;; Generating the tree.
  579.  
  580. (defun gnus-tree-node-insert (header sparse &optional adopted)
  581.   (let* ((dummy (stringp header))
  582.      (header (if (vectorp header) header
  583.            (progn
  584.              (setq header (make-mail-header "*****"))
  585.              (mail-header-set-number header 0)
  586.              (mail-header-set-lines header 0)
  587.              (mail-header-set-chars header 0)
  588.              header)))
  589.      (gnus-tmp-from (mail-header-from header))
  590.      (gnus-tmp-subject (mail-header-subject header))
  591.      (gnus-tmp-number (mail-header-number header))
  592.      (gnus-tmp-name
  593.       (cond
  594.        ((string-match "(.+)" gnus-tmp-from)
  595.         (substring gnus-tmp-from
  596.                (1+ (match-beginning 0)) (1- (match-end 0))))
  597.        ((string-match "<[^>]+> *$" gnus-tmp-from)
  598.         (let ((beg (match-beginning 0)))
  599.           (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from)
  600.                (substring gnus-tmp-from (1+ (match-beginning 0))
  601.                   (1- (match-end 0))))
  602.           (substring gnus-tmp-from 0 beg))))
  603.        ((memq gnus-tmp-number sparse)
  604.         "***")
  605.        (t gnus-tmp-from)))
  606.      (gnus-tmp-open-bracket
  607.       (cond ((memq gnus-tmp-number sparse)
  608.          (caadr gnus-tree-brackets))
  609.         (dummy (caaddr gnus-tree-brackets))
  610.         (adopted (car (nth 3 gnus-tree-brackets)))
  611.         (t (caar gnus-tree-brackets))))
  612.      (gnus-tmp-close-bracket
  613.       (cond ((memq gnus-tmp-number sparse)
  614.          (cdadr gnus-tree-brackets))
  615.         (adopted (cdr (nth 3 gnus-tree-brackets)))
  616.         (dummy
  617.          (cdaddr gnus-tree-brackets))
  618.         (t (cdar gnus-tree-brackets))))
  619.      (buffer-read-only nil)
  620.      beg end)
  621.     (gnus-add-text-properties
  622.      (setq beg (point))
  623.      (setq end (progn (eval gnus-tree-line-format-spec) (point)))
  624.      (list 'gnus-number gnus-tmp-number))
  625.     (when (or t (gnus-visual-p 'tree-highlight 'highlight))
  626.       (gnus-tree-highlight-node gnus-tmp-number beg end))))
  627.  
  628. (defun gnus-tree-highlight-node (article beg end)
  629.   "Highlight current line according to `gnus-summary-highlight'."
  630.   (let ((list gnus-summary-highlight)
  631.     face)
  632.     (save-excursion
  633.       (set-buffer gnus-summary-buffer)
  634.       (let* ((score (or (cdr (assq article gnus-newsgroup-scored))
  635.             gnus-summary-default-score 0))
  636.          (default gnus-summary-default-score)
  637.          (mark (or (gnus-summary-article-mark article) gnus-unread-mark)))
  638.     ;; Eval the cars of the lists until we find a match.
  639.     (while (and list
  640.             (not (eval (caar list))))
  641.       (setq list (cdr list)))))
  642.     (unless (eq (setq face (cdar list)) (get-text-property beg 'face))
  643.       (gnus-put-text-property
  644.        beg end 'face
  645.        (if (boundp face) (symbol-value face) face)))))
  646.  
  647. (defun gnus-tree-indent (level)
  648.   (insert (make-string (1- (* (1+ gnus-tree-node-length) level)) ? )))
  649.  
  650. (defvar gnus-tmp-limit)
  651. (defvar gnus-tmp-sparse)
  652. (defvar gnus-tmp-indent)
  653.  
  654. (defun gnus-generate-tree (thread)
  655.   "Generate a thread tree for THREAD."
  656.   (save-excursion
  657.     (set-buffer (gnus-get-tree-buffer))
  658.     (let ((buffer-read-only nil)
  659.       (gnus-tmp-indent 0))
  660.       (erase-buffer)
  661.       (funcall gnus-generate-tree-function thread 0)
  662.       (gnus-set-mode-line 'tree)
  663.       (goto-char (point-min))
  664.       (gnus-tree-minimize)
  665.       (gnus-tree-recenter)
  666.       (let ((selected (selected-window)))
  667.     (when (get-buffer-window (set-buffer gnus-tree-buffer) t)
  668.       (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
  669.       (gnus-horizontal-recenter)
  670.       (select-window selected))))))
  671.  
  672. (defun gnus-generate-horizontal-tree (thread level &optional dummyp adopted)
  673.   "Generate a horizontal tree."
  674.   (let* ((dummy (stringp (car thread)))
  675.      (do (or dummy
  676.          (and (car thread)
  677.               (memq (mail-header-number (car thread))
  678.                 gnus-tmp-limit))))
  679.      col beg)
  680.     (if (not do)
  681.     ;; We don't want this article.
  682.     (setq thread (cdr thread))
  683.       (if (not (bolp))
  684.       ;; Not the first article on the line, so we insert a "-".
  685.       (insert (car gnus-tree-parent-child-edges))
  686.     ;; If the level isn't zero, then we insert some indentation.
  687.     (unless (zerop level)
  688.       (gnus-tree-indent level)
  689.       (insert (cadr gnus-tree-parent-child-edges))
  690.       (setq col (- (setq beg (point)) (gnus-point-at-bol) 1))
  691.       ;; Draw "|" lines upwards.
  692.       (while (progn
  693.            (forward-line -1)
  694.            (forward-char col)
  695.            (= (following-char) ? ))
  696.         (delete-char 1)
  697.         (insert (caddr gnus-tree-parent-child-edges)))
  698.       (goto-char beg)))
  699.       (setq dummyp nil)
  700.       ;; Insert the article node.
  701.       (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted))
  702.     (if (null thread)
  703.     ;; End of the thread, so we go to the next line.
  704.     (unless (bolp)
  705.       (insert "\n"))
  706.       ;; Recurse downwards in all children of this article.
  707.       (while thread
  708.     (gnus-generate-horizontal-tree
  709.      (pop thread) (if do (1+ level) level)
  710.      (or dummyp dummy) dummy)))))
  711.  
  712. (defsubst gnus-tree-indent-vertical ()
  713.   (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent)
  714.         (- (point) (gnus-point-at-bol)))))
  715.     (when (> len 0)
  716.       (insert (make-string len ? )))))
  717.  
  718. (defsubst gnus-tree-forward-line (n)
  719.   (while (>= (decf n) 0)
  720.     (unless (zerop (forward-line 1))
  721.       (end-of-line)
  722.       (insert "\n")))
  723.   (end-of-line))
  724.  
  725. (defun gnus-generate-vertical-tree (thread level &optional dummyp adopted)
  726.   "Generate a vertical tree."
  727.   (let* ((dummy (stringp (car thread)))
  728.      (do (or dummy
  729.          (and (car thread)
  730.               (memq (mail-header-number (car thread))
  731.                 gnus-tmp-limit))))
  732.      beg)
  733.     (if (not do)
  734.     ;; We don't want this article.
  735.     (setq thread (cdr thread))
  736.       (if (not (save-excursion (beginning-of-line) (bobp)))
  737.       ;; Not the first article on the line, so we insert a "-".
  738.       (progn
  739.         (gnus-tree-indent-vertical)
  740.         (insert (make-string (/ gnus-tree-node-length 2) ? ))
  741.         (insert (caddr gnus-tree-parent-child-edges))
  742.         (gnus-tree-forward-line 1))
  743.     ;; If the level isn't zero, then we insert some indentation.
  744.     (unless (zerop gnus-tmp-indent)
  745.       (gnus-tree-forward-line (1- (* 2 level)))
  746.       (gnus-tree-indent-vertical)
  747.       (delete-char -1)
  748.       (insert (cadr gnus-tree-parent-child-edges))
  749.       (setq beg (point))
  750.       (forward-char -1)
  751.       ;; Draw "-" lines leftwards.
  752.       (while (= (char-after (1- (point))) ? )
  753.         (delete-char -1)
  754.         (insert (car gnus-tree-parent-child-edges))
  755.         (forward-char -1))
  756.       (goto-char beg)
  757.       (gnus-tree-forward-line 1)))
  758.       (setq dummyp nil)
  759.       ;; Insert the article node.
  760.       (gnus-tree-indent-vertical)
  761.       (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted)
  762.       (gnus-tree-forward-line 1))
  763.     (if (null thread)
  764.     ;; End of the thread, so we go to the next line.
  765.     (progn
  766.       (goto-char (point-min))
  767.       (end-of-line)
  768.       (incf gnus-tmp-indent))
  769.       ;; Recurse downwards in all children of this article.
  770.       (while thread
  771.     (gnus-generate-vertical-tree
  772.      (pop thread) (if do (1+ level) level)
  773.      (or dummyp dummy) dummy)))))
  774.  
  775. ;;; Interface functions.
  776.  
  777. (defun gnus-possibly-generate-tree (article &optional force)
  778.   "Generate the thread tree for ARTICLE if it isn't displayed already."
  779.   (when (save-excursion
  780.       (set-buffer gnus-summary-buffer)
  781.       (and gnus-use-trees
  782.            gnus-show-threads
  783.            (vectorp (gnus-summary-article-header article))))
  784.     (save-excursion
  785.       (let ((top (save-excursion
  786.            (set-buffer gnus-summary-buffer)
  787.            (gnus-cut-thread
  788.             (gnus-remove-thread
  789.              (mail-header-id
  790.               (gnus-summary-article-header article))
  791.              t))))
  792.         (gnus-tmp-limit gnus-newsgroup-limit)
  793.         (gnus-tmp-sparse gnus-newsgroup-sparse))
  794.     (when (or force
  795.           (not (eq top gnus-tree-displayed-thread)))
  796.       (gnus-generate-tree top)
  797.       (setq gnus-tree-displayed-thread top))))))
  798.  
  799. (defun gnus-tree-open (group)
  800.   (gnus-get-tree-buffer))
  801.  
  802. (defun gnus-tree-close (group)
  803.                     ;(gnus-kill-buffer gnus-tree-buffer)
  804.   )
  805.  
  806. (defun gnus-highlight-selected-tree (article)
  807.   "Highlight the selected article in the tree."
  808.   (let ((buf (current-buffer))
  809.     region)
  810.     (set-buffer gnus-tree-buffer)
  811.     (when (setq region (gnus-tree-article-region article))
  812.       (when (or (not gnus-selected-tree-overlay)
  813.         (gnus-extent-detached-p gnus-selected-tree-overlay))
  814.     ;; Create a new overlay.
  815.     (gnus-overlay-put
  816.      (setq gnus-selected-tree-overlay (gnus-make-overlay 1 2))
  817.      'face gnus-selected-tree-face))
  818.       ;; Move the overlay to the article.
  819.       (gnus-move-overlay
  820.        gnus-selected-tree-overlay (goto-char (car region)) (cdr region))
  821.       (gnus-tree-minimize)
  822.       (gnus-tree-recenter)
  823.       (let ((selected (selected-window)))
  824.     (when (get-buffer-window (set-buffer gnus-tree-buffer) t)
  825.       (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
  826.       (gnus-horizontal-recenter)
  827.       (select-window selected))))
  828.     ;; If we remove this save-excursion, it updates the wrong mode lines?!?
  829.     (save-excursion
  830.       (set-buffer gnus-tree-buffer)
  831.       (gnus-set-mode-line 'tree))
  832.     (set-buffer buf)))
  833.  
  834. (defun gnus-tree-highlight-article (article face)
  835.   (save-excursion
  836.     (set-buffer (gnus-get-tree-buffer))
  837.     (let (region)
  838.       (when (setq region (gnus-tree-article-region article))
  839.     (gnus-put-text-property (car region) (cdr region) 'face face)
  840.     (set-window-point
  841.      (get-buffer-window (current-buffer) t) (cdr region))))))
  842.  
  843. ;;;
  844. ;;; gnus-carpal
  845. ;;;
  846.  
  847. (defvar gnus-carpal-group-buffer-buttons
  848.   '(("next" . gnus-group-next-unread-group)
  849.     ("prev" . gnus-group-prev-unread-group)
  850.     ("read" . gnus-group-read-group)
  851.     ("select" . gnus-group-select-group)
  852.     ("catch-up" . gnus-group-catchup-current)
  853.     ("new-news" . gnus-group-get-new-news-this-group)
  854.     ("toggle-sub" . gnus-group-unsubscribe-current-group)
  855.     ("subscribe" . gnus-group-unsubscribe-group)
  856.     ("kill" . gnus-group-kill-group)
  857.     ("yank" . gnus-group-yank-group)
  858.     ("describe" . gnus-group-describe-group)
  859.     "list"
  860.     ("subscribed" . gnus-group-list-groups)
  861.     ("all" . gnus-group-list-all-groups)
  862.     ("killed" . gnus-group-list-killed)
  863.     ("zombies" . gnus-group-list-zombies)
  864.     ("matching" . gnus-group-list-matching)
  865.     ("post" . gnus-group-post-news)
  866.     ("mail" . gnus-group-mail)
  867.     ("rescan" . gnus-group-get-new-news)
  868.     ("browse-foreign" . gnus-group-browse-foreign)
  869.     ("exit" . gnus-group-exit)))
  870.  
  871. (defvar gnus-carpal-summary-buffer-buttons
  872.   '("mark"
  873.     ("read" . gnus-summary-mark-as-read-forward)
  874.     ("tick" . gnus-summary-tick-article-forward)
  875.     ("clear" . gnus-summary-clear-mark-forward)
  876.     ("expirable" . gnus-summary-mark-as-expirable)
  877.     "move"
  878.     ("scroll" . gnus-summary-next-page)
  879.     ("next-unread" . gnus-summary-next-unread-article)
  880.     ("prev-unread" . gnus-summary-prev-unread-article)
  881.     ("first" . gnus-summary-first-unread-article)
  882.     ("best" . gnus-summary-best-unread-article)
  883.     "article"
  884.     ("headers" . gnus-summary-toggle-header)
  885.     ("uudecode" . gnus-uu-decode-uu)
  886.     ("enter-digest" . gnus-summary-enter-digest-group)
  887.     ("fetch-parent" . gnus-summary-refer-parent-article)
  888.     "mail"
  889.     ("move" . gnus-summary-move-article)
  890.     ("copy" . gnus-summary-copy-article)
  891.     ("respool" . gnus-summary-respool-article)
  892.     "threads"
  893.     ("lower" . gnus-summary-lower-thread)
  894.     ("kill" . gnus-summary-kill-thread)
  895.     "post"
  896.     ("post" . gnus-summary-post-news)
  897.     ("mail" . gnus-summary-mail)
  898.     ("followup" . gnus-summary-followup-with-original)
  899.     ("reply" . gnus-summary-reply-with-original)
  900.     ("cancel" . gnus-summary-cancel-article)
  901.     "misc"
  902.     ("exit" . gnus-summary-exit)
  903.     ("fed-up" . gnus-summary-catchup-and-goto-next-group)))
  904.  
  905. (defvar gnus-carpal-server-buffer-buttons
  906.   '(("add" . gnus-server-add-server)
  907.     ("browse" . gnus-server-browse-server)
  908.     ("list" . gnus-server-list-servers)
  909.     ("kill" . gnus-server-kill-server)
  910.     ("yank" . gnus-server-yank-server)
  911.     ("copy" . gnus-server-copy-server)
  912.     ("exit" . gnus-server-exit)))
  913.  
  914. (defvar gnus-carpal-browse-buffer-buttons
  915.   '(("subscribe" . gnus-browse-unsubscribe-current-group)
  916.     ("exit" . gnus-browse-exit)))
  917.  
  918. (defvar gnus-carpal-group-buffer "*Carpal Group*")
  919. (defvar gnus-carpal-summary-buffer "*Carpal Summary*")
  920. (defvar gnus-carpal-server-buffer "*Carpal Server*")
  921. (defvar gnus-carpal-browse-buffer "*Carpal Browse*")
  922.  
  923. (defvar gnus-carpal-attached-buffer nil)
  924.  
  925. (defvar gnus-carpal-mode-hook nil
  926.   "*Hook run in carpal mode buffers.")
  927.  
  928. (defvar gnus-carpal-button-face 'bold
  929.   "*Face used on carpal buttons.")
  930.  
  931. (defvar gnus-carpal-header-face 'bold-italic
  932.   "*Face used on carpal buffer headers.")
  933.  
  934. (defvar gnus-carpal-mode-map nil)
  935. (put 'gnus-carpal-mode 'mode-class 'special)
  936.  
  937. (if gnus-carpal-mode-map
  938.     nil
  939.   (setq gnus-carpal-mode-map (make-keymap))
  940.   (suppress-keymap gnus-carpal-mode-map)
  941.   (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
  942.   (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
  943.   (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
  944.  
  945. (defun gnus-carpal-mode ()
  946.   "Major mode for clicking buttons.
  947.  
  948. All normal editing commands are switched off.
  949. \\<gnus-carpal-mode-map>
  950. The following commands are available:
  951.  
  952. \\{gnus-carpal-mode-map}"
  953.   (interactive)
  954.   (kill-all-local-variables)
  955.   (setq mode-line-modified (cdr gnus-mode-line-modified))
  956.   (setq major-mode 'gnus-carpal-mode)
  957.   (setq mode-name "Gnus Carpal")
  958.   (setq mode-line-process nil)
  959.   (use-local-map gnus-carpal-mode-map)
  960.   (buffer-disable-undo (current-buffer))
  961.   (setq buffer-read-only t)
  962.   (make-local-variable 'gnus-carpal-attached-buffer)
  963.   (run-hooks 'gnus-carpal-mode-hook))
  964.  
  965. (defun gnus-carpal-setup-buffer (type)
  966.   (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
  967.     (if (get-buffer buffer)
  968.     ()
  969.       (save-excursion
  970.     (set-buffer (get-buffer-create buffer))
  971.     (gnus-carpal-mode)
  972.     (setq gnus-carpal-attached-buffer
  973.           (intern (format "gnus-%s-buffer" type)))
  974.     (gnus-add-current-to-buffer-list)
  975.     (let ((buttons (symbol-value
  976.             (intern (format "gnus-carpal-%s-buffer-buttons"
  977.                     type))))
  978.           (buffer-read-only nil)
  979.           button)
  980.       (while buttons
  981.         (setq button (car buttons)
  982.           buttons (cdr buttons))
  983.         (if (stringp button)
  984.         (gnus-set-text-properties
  985.          (point)
  986.          (prog2 (insert button) (point) (insert " "))
  987.          (list 'face gnus-carpal-header-face))
  988.           (gnus-set-text-properties
  989.            (point)
  990.            (prog2 (insert (car button)) (point) (insert " "))
  991.            (list 'gnus-callback (cdr button)
  992.              'face gnus-carpal-button-face
  993.              gnus-mouse-face-prop 'highlight))))
  994.       (let ((fill-column (- (window-width) 2)))
  995.         (fill-region (point-min) (point-max)))
  996.       (set-window-point (get-buffer-window (current-buffer))
  997.                 (point-min)))))))
  998.  
  999. (defun gnus-carpal-select ()
  1000.   "Select the button under point."
  1001.   (interactive)
  1002.   (let ((func (get-text-property (point) 'gnus-callback)))
  1003.     (if (null func)
  1004.     ()
  1005.       (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
  1006.       (call-interactively func))))
  1007.  
  1008. (defun gnus-carpal-mouse-select (event)
  1009.   "Select the button under the mouse pointer."
  1010.   (interactive "e")
  1011.   (mouse-set-point event)
  1012.   (gnus-carpal-select))
  1013.  
  1014. ;;; Allow redefinition of functions.
  1015. (gnus-ems-redefine)
  1016.  
  1017. (provide 'gnus-salt)
  1018.  
  1019. ;;; gnus-salt.el ends here
  1020.